home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / debug / mutation.scm < prev    next >
Text File  |  1995-10-13  |  3KB  |  131 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4.  
  5. ; Package mutation tests
  6.  
  7. "
  8. ,translate =scheme48/ ./
  9. ,open packages compiler built-in-structures handle condition
  10. ,open interfaces table defpackage package-mutation
  11. "
  12.  
  13. (define (try exp env . should-return-option)
  14.   (let ((val (ignore-errors (lambda () (eval exp env)))))
  15.     (if (if (null? should-return-option)
  16.         (error? val)
  17.         (not (if (eq? (car should-return-option) 'error)
  18.              (error? val)
  19.              (eq? val (car should-return-option)))))
  20.     (begin (write `(lost: ,exp => ,val))
  21.            (newline)))))
  22.  
  23. (define p1 (make-simple-package (list scheme) eval #f 'p1))
  24.  
  25. (try 'a p1 'error)
  26.  
  27. (try '(define a 'aa) p1)
  28. (try 'a p1 'aa)
  29.  
  30. (try '(define (foo) b) p1)
  31. (try '(foo) p1 'error)
  32.  
  33. (try '(define b 'bb) p1)
  34. (try 'b p1 'bb)
  35. (try '(foo) p1 'bb)
  36.  
  37.  
  38. (define s1-sig (make-simple-interface 's1-sig '(((a b c d e f) value))))
  39. (define s1 (make-structure p1 (lambda () s1-sig) 's1))
  40.  
  41. (define p2 (make-simple-package (list s1 scheme) eval #f 'p2))
  42.  
  43. (try 'b p2 'bb)
  44. (try 'c p2 'error)
  45. (try 'z p2 'error)
  46.  
  47. (try '(define (bar) c) p2)
  48. (try '(bar) p2 'error)
  49. (try '(define c 'cc) p1)
  50. (try 'c p2 'cc)
  51. (try '(bar) p2 'cc)
  52.  
  53. (try '(define (baz1) d) p1)
  54. (try '(define (baz2) d) p2)
  55. (try '(baz1) p1 'error)
  56. (try '(baz2) p2 'error)
  57. (try '(define d 'dd) p1)
  58. (try '(baz1) p1 'dd)
  59. (try '(baz2) p2 'dd)
  60.  
  61. ; Shadow
  62. (try '(define d 'shadowed) p2)
  63. (try '(baz1) p1 'dd)
  64. (try '(baz2) p2 'shadowed)
  65.  
  66. ; Shadow undefined
  67. (try '(define (moo1) f) p1)
  68. (try '(define (moo2) f) p2)
  69. (try '(define f 'ff) p2)
  70. (try '(moo1) p1 'error)
  71. (try '(moo2) p2 'ff)
  72.  
  73.  
  74. (try '(define (quux1) e) p1)
  75. (try '(define (quux2) e) p2)
  76. (try '(define (quux3 x) (set! e x)) p1)
  77. (try '(define (quux4 x) (set! e x)) p2)
  78. ;
  79. (try '(quux1) p1 'error)
  80. (try '(quux2) p2 'error)
  81. (try '(quux3 'q3) p1 'error)
  82. (try '(quux4 'q4) p2 'error)
  83. ;
  84. (try '(define e 'ee) p1)
  85. (try '(quux1) p1 'ee)
  86. (try '(quux2) p2 'ee)
  87. (try '(quux3 'q3) p1)
  88. (try '(quux1) p1 'q3)
  89. (try '(quux2) p2 'q3)
  90. (try '(quux4 'q4) p2 'error)
  91. ;
  92. (try '(define e 'ee2) p2)
  93. (try '(quux1) p1 'q3)
  94. (try '(quux2) p2 'ee2)
  95. (try '(quux3 'qq3) p1)
  96. (try '(quux4 'qq4) p2)
  97. (try '(quux1) p1 'qq3)
  98. (try '(quux2) p2 'qq4)
  99.  
  100.  
  101. ; (set-verify-later! really-verify-later!)
  102.  
  103. (define-interface s3-sig (export a b x y z))
  104.  
  105. (define s3
  106.   (make-structure p1 (lambda () s3-sig) 's3))
  107.  
  108. (define p4 (make-simple-package (list s3 scheme) eval #f 'p4))
  109.  
  110. (try '(define (fuu1) a) p4)
  111. (try '(define (fuu2) d) p4)
  112. (try '(fuu1) p4 'aa)
  113. (try '(fuu2) p4 'error)
  114.  
  115. ; Remove a, add d
  116. (define-interface s3-sig (export b d x y z))
  117. ;(package-system-sentinel)
  118.  
  119. (try 'a p4 'error)
  120. (try 'd p4 'dd)
  121. (try '(fuu2) p4 'dd)
  122. (try '(fuu1) p4 'error)    ; Foo.
  123.  
  124.  
  125.  
  126. (define (table->alist t)
  127.   (let ((l '()))
  128.     (table-walk (lambda (key val) (set! l (cons (cons key val) l))) t)
  129.     l))
  130.  
  131.